home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / configure.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  4.4 KB  |  147 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # get configure info for all of the widgets (Simplified version)
  8. # The commands in this file are used to derive information about
  9. # widgets, options, etc.  This information needs to be computed once
  10. # for each version of TK, and is invariant across all applications
  11.  
  12. # find all tcl commands that are widgets
  13. #   <command> .xxx must work and return .xxx
  14. #   winfo exists .xxx must be true
  15. # For each widget, extract info into an array
  16.  
  17. # [This is the *old* tK3.6 version]
  18.  
  19. proc configure_widget_data {{var Widget_data} {check ._check_} {cmd ""}} {
  20.     upvar $var data
  21.     catch {destroy $check}
  22.  
  23.     # only need to run this 1'ce
  24.     if {[info exists data(widgets)]} {
  25.         return $data(widgets)
  26.     }
  27.     array set skip {
  28.         toplevel 1 exit 1 destroy 1 puts 1 eval 1 menu 1 sh 1 spawn 1 
  29.         vwait 1 quit 1
  30.     }
  31.  
  32.     foreach i [info commands] {
  33.         if {[string index $i 0] == "."} continue    ;# skip widget inst's
  34.         if {[info exists skip($i)]} continue            ;# skip these
  35.         if {[string match exp_* $i]} continue            ;# skip these too
  36.         if {[info procs $i] == $i} continue            ;# skip procedures
  37.         # if {$i == "text"} {set do "text -font fixed"} {set do $i}
  38.         set do $i
  39.         dputs $i
  40.         if {[catch "$do $check" foo]}  continue
  41.         if {[winfo exists $check]} {
  42.             if {$cmd != ""} {
  43.                 eval "$cmd $i"
  44.             }
  45.             lappend widgets $i
  46.             fetch_widget_data $i data $check
  47.         }
  48.         catch {destroy $check}
  49.     }
  50.     set data(widgets) $widgets
  51.     return $widgets
  52. }
  53.  
  54. # build an array containing widget options
  55.  
  56. proc fetch_widget_data {widget {array_name Widget_data} {check ._check_}} {
  57.     upvar $array_name data
  58.  
  59.     # query configuration options
  60.  
  61.     set all [$check configure]
  62.     catch {unset data(options:$widget)}    ;# incase we re-source
  63.     foreach option $all {
  64.         if {[regexp {^-([^ ]+) [^ ]+ [^ ]+ ([^ ]+) .*} $option x name value]} {
  65.             set data(default:$widget,$name) $value
  66.             dputs "$widget $option"
  67.             lappend data(options:$widget) $name
  68.             if {![info exists data(option:$name)]} {
  69.                 set data(option:$name) [get_option_type $check $widget $name]
  70.             }
  71.         }
  72.     }
  73.     return ""
  74. }
  75.  
  76. # return the type of an option
  77. # the only *guaranteed* way to do this is by creating a new widget for
  78. # each test, as some invalid options leave the widgets in an undefined state
  79. # Thats too slow, so We'll keep a list of "bad" options and deal with them
  80. # separately
  81.  
  82. proc get_option_type {name widget option {font fixed}} {
  83.  
  84.     # try to set the option to these values.  Keep track of the values
  85.     # that work. 
  86.  
  87.     set tests "2 1 1c #123 ne raised warning arrow disabled vertical $font"
  88.     array set bad_options {image 1 orient 1}
  89.     set bad [expr [info exists bad_options($option)] == 1]
  90.  
  91.     foreach test $tests {
  92.         set result [catch "$name configure -$option $test" _Message]
  93.         append out $result
  94.         if {$result && $bad} {
  95.             destroy $name; $widget $name
  96.         }
  97.     }
  98.     return [assign_option_type $out]
  99. }
  100.  
  101. # assign a type to result pattern
  102. # This depends on the types and order of tests performed in
  103. # get_option_types
  104. #   pat:  The list of successes/failures for each test
  105.  
  106. proc assign_option_type {pat} {
  107.     switch -exact $pat {
  108.         00000000000 {set result string}
  109.         00011111111 {set result distance}
  110.         00111111111 {set result integer}
  111.         10111111111 {set result boolean}
  112.         11101111111 {set result color}
  113.         11110111111 {set result anchor}
  114.         11111011111 {set result relief}
  115.         11111101111 {set result bitmap}
  116.         11111110111 {set result cursor}
  117.         11111111011 {set result state}
  118.         11111111101 {set result orientation}
  119.         11111111110 {set result font}
  120.         11111111111 {set result special}
  121.         default      {set result unknown}
  122.     }
  123. return $result
  124. }
  125.  
  126. # configure the widget data for the table geometry manager
  127. # This is hard-wired for now create something to manage, manage it
  128. # extract the management options, then destroy it.
  129. # for now, we'll pretend the geometry manager is like a widget,
  130. # and configure its data the same way  This will change with the new
  131. # table geometry manager
  132.  
  133. proc configure_geometry_data {{var Widget_data} {check ._check_}} {
  134.     upvar #0 $var data
  135.     frame $check
  136.     frame $check.1
  137.     blt_table $check $check.1 0,0
  138.     regsub -all { -} [blt_table info $check.1] { default:table,} options
  139.     regsub -all pad $options wad options    ;# botch for padding
  140.     regsub -all anchor $options align options    ;# botch for padding
  141.     destroy $check
  142.     array set data [lrange $options 2 end]
  143.     foreach i {row column} {
  144.         set data(default:position,$i) 0
  145.     }
  146. }
  147.